Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/chap09/howto06/ccwsock2.pas

Pascal/Delphi Source File | 1996-02-15 | 35.6 KB | 946 lines

unit CCWSock2;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Winsock;
const
  { This is the base message used by Winsock to notify of Winsock asynch act }
  WM_ASYNCSELECT = WM_USER + 0;
type
  { These data types translate the c-like winsock unit names }
  Server_Entry = TServEnt;
  PServer_Entry = ^Server_Entry;
  Protocol_Entry = TProtoEnt;
  PProtocol_Entry = ^Protocol_Entry;
  Internet_Address = TInAddr;
  PInternet_address = ^Internet_Address;
  Internet_Socket_Address = TSockAddrIn;
  PInternet_Socket_Address = ^Internet_Socket_Address;
  Host_Entry = THostEnt;
  PHost_entry = ^Host_Entry;
  Winsock_Implementation_Data = TWSAData;
  Generic_Socket_Address = Internet_Socket_Address;
  Socket_Protocol = TSockProto;
  Lingering_Control = TLinger;
  { These two event data types are used to hook into the Winsock Asynch system }
  TWSAEvent = procedure( Sender : TObject; Socket : TSocket ) of object;
  TWSAError = procedure( Sender     : TObject;
                         ErrorCode  : Integer;
                         TheMessage : String ) of object;
  TCCSocket = class( TWinControl )
  public
    Socket_WSA_Data       : Winsock_Implementation_Data;
    ErrorCode           : Integer;
    FullErrorMessage    : string;
    WinsockErrorMessage : string;
    Socket_Server_Entry   : PServer_Entry;
    Socket_Host_Entry     : Phost_entry;
    Socket_Protocol_Entry : PProtocol_Entry;
    Socket_IP_Address     : Internet_Socket_Address;
    FPort_Name            : String;
    FIP_Address_Name      : String;
    FSocket               : TSocket;
    FMasterSocket         : TSocket;
    FBlockingMode         : Boolean;
    FTimeoutValue         : Integer;
    FOnDataIsAvailable    : TWSAEvent;
    FOnDataCanBeSent      : TWSAEvent;
    FOnOOBDataIsAvailable : TWSAEvent;
    FOnSessionClosed      : TWSAEvent;
    FOnSessionIsAvailable : TWSAEvent;
    FOnSessionConnected   : TWSAEvent;
    FOnErrorOccurred      : TWSAError;
    procedure SetStringData( TheData: string );
    function GetStringData          : string;
    procedure SetStringDataOutOfBand( TheData: string );
    function GetStringDataOutOfBand : string;
    function PeekCurrentData        : string;
    function GetSocketErrorDescription( ErrorCode : Integer) : string;
    procedure SetSocketErrorData( SocketFunction : string );
    procedure TWMPaint( var Msg : TWMPaint ); message WM_PAINT;
    procedure ActivateNonAsynchTimeout;
    procedure DeactivateNonAsynchTimeout;
    procedure WMASyncSelect( var Msg : TMessage ); message WM_ASYNCSELECT;
    procedure WMTimer( var Msg : TMessage ); message WM_TIMER;
    constructor Create( AOwner : TComponent ); override;
    destructor Destroy; override;
    procedure CCSockConnect;
    procedure CCSockClose;
    procedure CCSockListen;
    procedure CCSockCancelListen;
    function CCSockReceive(     TheSocket     : TSocket;
                                TheTextBuffer : PChar;
                            var TheTextLength : Integer
                          ) : Integer;
    function CCSockSend(    TheSocket     : TSocket;
                            TheTextBuffer : PChar;
                        var TheTextLength : Integer
                       ) : Integer;
    function CCSockAccept                                  : TSocket;
    function GetSocketIPAddress( TheSocket: TSocket )      : string;
    function GetSocketPort( TheSocket : TSocket )          : string;
    function GetSocketPeerIPAddress( TheSocket : TSocket ) : string;
    function GetSocketPeerPort( TheSocket : TSocket )      : string;
    function SocketIsNotBlocking                           : Boolean;
    procedure ActivateBlockingMode( BeginBlocking : Boolean );
    property StringData      : string
     read GetStringData write SetStringData;
    property PeekData        : string
     read PeekCurrentData;
    property OutOfBand       : string
     read GetStringDataOutOfBand write SetStringDataOutOfBand;
    property TheSocket       : TSocket
     read FSocket write FSocket;
    property TheMasterSocket : TSocket
     read FMasterSocket write FMasterSocket;
  published
    property IPAddressName        : string
     read FIP_Address_Name write FIP_Address_Name;
    property PortName             : string
     read FPort_Name write FPort_Name;
    property AsynchMode           : Boolean
     read SocketIsNotBlocking write ActivateBlockingMode default True;
    property NonAsynchTimeoutValue   : Integer
     read FTimeoutValue write FTimeoutValue default 30;
    property OnDataIsAvailable    : TWSAEvent
     read FOnDataIsAvailable write FOnDataIsAvailable;
    property OnOOBDataIsAvailable    : TWSAEvent
     read FOnOOBDataIsAvailable write FOnOOBDataIsAvailable;
    property OnDataCanBeSent    : TWSAEvent
     read FOnDataCanBeSent write FOnDataCanBeSent;
    property OnSessionClosed      : TWSAEvent
     read FOnSessionClosed write FOnSessionClosed;
    property OnSessionIsAvailable : TWSAEvent
     read FOnSessionIsAvailable write FOnSessionIsAvailable;
    property OnSessionConnected   : TWSAEvent
     read FOnSessionConnected write FOnSessionConnected;
    property OnErrorOccurred      : TWSAError
     read FOnErrorOccurred write FOnErrorOccurred;
  end;
  CCHost_Entry = packed record
    Host_Name              : PChar;
    Host_Aliases           : ^PChar;
    Host_Address_Type      : smallint;
    Host_Address_Length    : smallint;
    Case Integer of        { Another useful variant record    }
    0: ( host_address_list : ^PChar ); { Double pointer again }
    1: ( host_address      : ^PInternet_address );
  end;

implementation

{ This is the override create method for the socket component }
constructor TCCSocket.Create( AOwner : TComponent );
var
  ReturnCode : Integer; { Used to signal error }
begin
  { Call inherited first! }
  inherited Create( AOwner );
  { Enable Asynch mode since in Windows }
  FBlockingMode := false;
  { Set Timeout for asynch ops }
  FTimeoutValue := 30;
  { Set up no sockets in the two native vars }
  FSocket := INVALID_SOCKET;
  FMasterSocket := INVALID_SOCKET;
  { Start up Winsock }
  ReturnCode := WSAStartup( $101 , Socket_WSA_Data );
  { If don't get 0 store the error code }
  if ReturnCode <> 0 then SetSocketErrorData( 'Constructor (WSAStartup)' );
end;

{ This is the destroy override method }
destructor TCCSocket.Destroy;
var
  ReturnCode : Integer; { Holds possible error code }
begin
  { Attempt to shut down winsock }
  ReturnCode := WSACleanup;
  { If didn't get 0 save the error }
  if ReturnCode < 0 then SetSocketErrorData( 'Destructor (WSACleanup)' );
  { call inherited }
  inherited Destroy;
end;

{ This is just used to draw the nonvisual element during design time }
procedure TCCSocket.TWMPaint( var Msg : TWMPaint );
var
  TheIcon : HIcon; { Internal icon }
  TheDC   : HDC;   { Internal dc   }
begin
  { If in design mode draw the icon }
  if csDesigning in ComponentState then
  begin
    { Load the icon from the instance via the DCR file }
    TheIcon := LoadIcon( HInstance , MAKEINTRESOURCE( 'TCCSocket' ));
    { Get a device context }
    TheDC := GetDC( Handle );
    { Set the internal width to that of an icon }
    Width := 32;
    Height := 32;
    { Display the icon }
    DrawIcon( TheDC , 0 , 0 , TheIcon );
    { Get rid of the evidence }
    ReleaseDC( Handle , TheDC );
    FreeResource( TheIcon );
  end;
  { Let Windows know drawing is done }
  ValidateRect( Handle , nil );
end;

{ Function to return Asynch mode }
function TCCSocket.SocketIsNotBlocking: Boolean;
begin
  { return inverse of blocking mode }
  SocketIsNotBlocking := not FBlockingMode;
end;

{ This turns off asynch mode via inverse of parameter }
procedure TCCSocket.ActivateBlockingMode( BeginBlocking: Boolean );
begin
  FBlockingMode := not BeginBlocking;
end;

{ This is a full access method to send a string over the socket }
procedure TCCSocket.SetStringData( TheData : string );
var
  BytesLeftToSend   ,                         { Counter for remaining data }
  BytesSentSoFar    : Integer;                { Counter for sent data      }
  DataBuffer        : array[0..256] of char;  { Buffer for string          }
  DataBufferPointer : PChar;                  { Pointer to buffer          }
begin
  { Copy string into char array }
  StrPCopy( DataBuffer , TheData );
  { Move the pointer to the array's first element into the PChar }
  DataBufferPointer := @DataBuffer[ 0 ];
  { Count the total chars to send }
  BytesLeftToSend := Length( TheData );
  { Run a loop to send the string over the socket }
  while BytesLeftToSend > 0 do
  begin
    { Start a timeout timer if not in blocking mode }
    if not FBlockingMode then ActivateNonAsynchTimeout;
    { Send some bytes over the net }
    BytesSentSoFar := send( FSocket , DataBufferPointer , BytesLeftToSend , 0 );
    { End timeout timer if not blocking }
    if not FBlockingMode then DeactivateNonAsynchTimeout;
    { If get a negative response code then signal error }
    if BytesSentSoFar < 0 then
    begin
      { Save the error data }
      SetSocketErrorData( 'SetStringData (Send)' );
    end
    else
    begin
      { Decrement total bytes left to send }
      BytesLeftToSend := BytesLeftToSend - BytesSentSoFar;
      { Increment pointer into the string }
      DataBufferPointer := DataBufferPointer + BytesSentSoFar;
    end;
  end;
end;

{ This is a full access method to read a string from the socket }
function TCCSocket.GetStringData: string;
var
  TheDataLength     : Integer; { Length of data received }
  DataBuffer        : string;  { String to store data in }
  ThePC             : PChar;
begin
  { If the socket has been set up try to get some data }
  if FSocket <> INVALID_SOCKET then
  begin
    GetMem( ThePC , 256 );
    { Activate timeout timer if not in blocking mode }
    if not FBlockingMode then ActivateNonAsynchTimeout;
    { Do a receive on any data waiting at the socket }
    TheDataLength := recv( FSocket , ThePC , 255 , 0 );
    { If not blocking kill timeout timer }
    if not FBlockingMode then DeactivateNonAsynchTimeout;
    { If negative data length then set error }
    if TheDataLength < 0 then
    begin
      { Set the socket error conditions }
      SetSocketErrorData( 'GetStringData (Recv)' );
      { Return nothing }
      Result := '';
    end
    else
    begin
      DataBuffer := StrPas( ThePC );
      { And return the prepared string as result }
      Result := DataBuffer;
    end;
    FreeMem( ThePC , 256 );
  end
  else Result := ''; { Return empty string if invalid socket }
end;

{ This is a full access method to send a string as OOB data }
procedure TCCSocket.SetStringDataOutOfBand( TheData: string );
var
  BytesLeftToSend   ,                         { Counter for remaining data }
  BytesSentSoFar    : Integer;                { Counter for sent data      }
  DataBuffer        : array[0..256] of char;  { Buffer for string          }
  DataBufferPointer : PChar;                  { Pointer to buffer          }
begin
  { Copy string into char array }
  StrPCopy( DataBuffer , TheData );
  { Move the pointer to the array's first element into the PChar }
  DataBufferPointer := @DataBuffer[ 0 ];
  { Count the total chars to send }
  BytesLeftToSend := Length( TheData );
  { Run a loop to send the string over the socket }
  while BytesLeftToSend > 0 do
  begin
    { Start a timeout timer if not in blocking mode }
    if not FBlockingMode then ActivateNonAsynchTimeout;
    { Send some bytes over the net }
    BytesSentSoFar := send( FSocket , DataBufferPointer ,
                            BytesLeftToSend , MSG_OOB );
    { End timeout timer if not blocking }
    if not FBlockingMode then DeactivateNonAsynchTimeout;
    { If get a negative response code then signal error }
    if BytesSentSoFar < 0 then
    begin
      { Save the error data }
      SetSocketErrorData( 'SetStringDataOutOfBand (Send)' );
    end
    else
    begin
      { Decrement total bytes left to send }
      BytesLeftToSend := BytesLeftToSend - BytesSentSoFar;
      { Increment pointer into the string }
      DataBufferPointer := DataBufferPointer + BytesSentSoFar;
    end;
  end;
end;

{ This is a full access method to receive out of band data as a string }
function TCCSocket.GetStringDataOutOfBand: string;
var
  TheDataLength     : Integer; { Length of data received }
  DataBuffer        : string;  { String to store data in }
  ThePC             : PChar;
begin
  { If the socket has been set up try to get some data }
  if FSocket <> INVALID_SOCKET then
  begin
    GetMem( ThePC , 256 );
    { Activate timeout timer if not in blocking mode }
    if not FBlockingMode then ActivateNonAsynchTimeout;
    { Do a receive on any data waiting at the socket }
    TheDataLength := recv( FSocket , ThePC , 255 , MSG_OOB );
    { If not blocking kill timeout timer }
    if not FBlockingMode then DeactivateNonAsynchTimeout;
    { If negative data length then set error }
    if TheDataLength < 0 then
    begin
      { Set the socket error conditions }
      SetSocketErrorData( 'GetStringDataOutOfBand (Recv)' );
      { Return nothing }
      Result := '';
    end
    else
    begin
      DataBuffer := StrPas( ThePC );
      { And return the prepared string as result }
      Result := DataBuffer;
    end;
    FreeMem( ThePC , 256 );
  end
  else Result := ''; { Return empty string if invalid socket }
end;

function TCCSocket.PeekCurrentData: string;
var
  TheDataLength     : Integer; { Length of data received }
  DataBuffer        : string;  { String to store data in }
  ThePC             : PChar;
begin
  { If the socket has been set up try to get some data }
  if FSocket <> INVALID_SOCKET then
  begin
    GetMem( ThePC , 256 );
    { Activate timeout timer if not in blocking mode }
    if not FBlockingMode then ActivateNonAsynchTimeout;
    { Do a receive on any data waiting at the socket }
    TheDataLength := recv( FSocket , ThePC , 255 , MSG_PEEK );
    { If not blocking kill timeout timer }
    if not FBlockingMode then DeactivateNonAsynchTimeout;
    { If negative data length then set error }
    if TheDataLength < 0 then
    begin
      { Set the socket error conditions }
      SetSocketErrorData( 'PeekCurrentData (PeekData)' );
      { Return nothing }
      Result := '';
    end
    else
    begin
      DataBuffer := StrPas( ThePC );
      { And return the prepared string as result }
      Result := DataBuffer;
    end;
    FreeMem( ThePC , 256 );
  end
  else Result := ''; { Return empty string if invalid socket }
end;

{ This is a full access method to get the port id for a given socket }
function TCCSocket.GetSocketPort( TheSocket : TSocket ) : string;
var
  TheAddress       : Internet_Socket_Address;  { Hold address info     }
  TheAddressLength : Integer;                  { Hold addr info length }
begin
  { Find out the size of the structure }
  TheAddressLength := SizeOf( TheAddress );
  { Call the winsock dll routine }
  getsockname( TheSocket , TheAddress , TheAddressLength );
  { Pull off the properly-byte-ordered port number as a string }
  Result := IntToStr( ntohs( TheAddress.sin_port ));
end;

{ This is a full access method to get the IP Address of a given socket }
function TCCSocket.GetSocketIPAddress( TheSocket : TSocket ) : string;
var
  TheAddress       : Internet_Socket_Address; { Holds address info   }
  TheAddressLength : Integer;                 { Holds size of info   }
  AddressPChar     : PChar;                   { holds converted info }
begin
  { Get the size of the address record }
  TheAddressLength := SizeOf( TheAddress );
  { Call the Winsock DLL function }
  getsockname( TheSocket , TheAddress , TheAddressLength );
  { Make the conversion from 32 bit to dotted decimal }
  AddressPChar := inet_ntoa( TheAddress.sin_addr );
  { return it as a pascal string }
  Result := StrPas( AddressPChar );
end;

{ This is a full access method to get the port number of the other end of a socket }
function TCCSocket.GetSocketPeerPort( TheSocket : TSocket ) : string;
var
  TheAddress       : Internet_Socket_Address;  { Hold address info     }
  TheAddressLength : Integer;                  { Hold addr info length }
begin
  { Find out the size of the structure }
  TheAddressLength := SizeOf( TheAddress );
  { Call the winsock dll routine }
  getpeername( TheSocket , TheAddress , TheAddressLength );
  { Pull off the properly-byte-ordered port number as a string }
  Result := IntToStr( ntohs( TheAddress.sin_port ));
end;

{ This is a full access method to get the ip address of the other end of a socket }
function TCCSocket.GetSocketPeerIPAddress(TheSocket: TSocket): string;
var
  TheAddress       : Internet_Socket_Address; { Holds address info   }
  TheAddressLength : Integer;                 { Holds size of info   }
  AddressPChar     : PChar;                   { holds converted info }
begin
  { Get the size of the address record }
  TheAddressLength := SizeOf( TheAddress );
  { Call the Winsock DLL function }
  getpeername( TheSocket , TheAddress , TheAddressLength );
  { Make the conversion from 32 bit to dotted decimal }
  AddressPChar := inet_ntoa( TheAddress.sin_addr );
  { return it as a pascal string }
  Result := StrPas( AddressPChar );
end;

{ This is a full access method to receive a PChar of up to 64K of data at once }
function TCCSocket.CCSockReceive(    TheSocket     : TSocket;
                                     TheTextBuffer : PChar;
                                 var TheTextLength : Integer
                                ) : Integer;
begin
  { If not an invalid socket then do the receive }
  if FSocket <> INVALID_SOCKET then
  begin
    { If not in block mode then activate timeout timer }
    if not FBlockingMode then ActivateNonAsynchTimeout;
    { Return the direct result of the recv call into Winsock }
    Result := recv( TheSocket , TheTextBuffer , TheTextLength , 0 );
    { If not blocking kill timeout timer }
    if not FBlockingMode then DeactivateNonAsynchTimeout;
    { If negative length then get error info }
    if TheTextLength < 0 then SetSocketErrorData( 'CCSockReceive' );
  end
  else Result := -1; { Return invalid PChar if not valid socket }
end;

{ This is a full access method to send a PChar of up to 64K of data at once }
function TCCSocket.CCSockSend(    TheSocket     : TSocket;
                                  TheTextBuffer : PChar;
                              var TheTextLength : Integer
                             ) : Integer;
begin
  { If not blocking then activate timeout timer }
  if not FBlockingMode then ActivateNonAsynchTimeout;
  { Send the info through raw }
  TheTextLength := send( TheSocket , TheTextBuffer , TheTextLength , 0 );
  { if not blocking then deactivate timeout timer }
  if not FBlockingMode then DeactivateNonAsynchTimeout;
  { if error code then get winsock error status }
  if TheTextLength < 0 then SetSocketErrorData( 'CCSockSend' );
  { return SOCKET_ERROR or number of bytes sent }
  Result := TheTextLength;
end;

{ This method handles Asynchronous Windows messages for the Winsock }
procedure TCCSocket.WMASyncSelect( var Msg : TMessage );
begin
  { The low word of the lParam field of the Msg is the event code }
  case LoWord( Msg.lParam ) of
    { This indicates data is available for reading on the socket }
    FD_READ : begin
                if Assigned( FOnDataIsAvailable ) then
                 FOnDataIsAvailable( Self , Msg.wParam ); { wParam = socket ID }
              end;
    { This indicates data is available for sending on the socket }
    FD_WRITE : begin
                if Assigned( FOnDataCanBeSent ) then
                 FOnDataCanBeSent( Self , Msg.wParam );
              end;
    { This indicates OOB data is available for reading on the socket }
    FD_OOB : begin
                if Assigned( FOnOOBDataIsAvailable ) then
                 FOnOOBDataIsAvailable( Self , Msg.wParam );
              end;
    { This indicates the socket has an incoming connection for accept }
    FD_ACCEPT : begin
                  if Assigned( FOnSessionIsAvailable ) then
                   FOnSessionIsAvailable( Self , Msg.wParam );
                end;
    { This indicates an outgoing connection has been accepted by peer }
    FD_CONNECT: begin
                  if Assigned( FOnSessionConnected ) then
                   FOnSessionConnected( Self , Msg.wParam );
                end;
    { This indicates the socket has been closed; presumably by peer }
    FD_CLOSE : begin
                 if Assigned( FOnSessionClosed ) then
                  FOnSessionClosed( Self , Msg.wParam );
               end;
  end;
end;

{ This handles Asynchronous Timeouts gracefully }
procedure TCCSocket.WMTimer( var Msg : TMessage );
begin
  { Kill a running timer }
  KillTimer( Handle , 10 );
  { If the socket is blocking then deal with timeout }
  if WSAIsBlocking then
  begin
    { Cancel the blocking operation }
    WSACancelBlockingCall;
    { Return blocking call timeout error message }
    if Assigned( FOnErrorOccurred ) then
      FOnErrorOccurred( Self , WSAETIMEDOUT , 'Blocking call timed out' );
  end;
end;

{ This is a wrapper method around the complexity of connecting a socket }
procedure TCCSocket.CCSockConnect;
var
  ReturnCode : Integer;                    { Generic return code var }
  TcpPChar   : PChar;                      { Boilerplate TCP string  }
  PortName   : array[ 0 .. 31 ] of char;   { PChar for port name     }
  DataBuffer : array[ 0 .. 256 ] of char;  { Generic buffer PChar    }
  DummyValue : longint;                    { Must use variable call  }
  The_Socket_Host_Entry : CCHost_Entry;
begin
  { No port name set error }
  if FPort_Name = '' then
  begin
    SetSocketErrorData( 'No Valid Port Name in CCSockConnect');
    exit;
  end;
  { No IP address set error }
  if FIP_Address_Name = '' then
  begin
    SetSocketErrorData( 'No Valid IP Address in CCSockConnect');
    exit;
  end;
  { Set required family value }
  Socket_IP_Address.sin_family := AF_INET;
  { Move the port name into the PChar }
  StrPCopy( PortName , FPort_Name );
  { Set up the boilerplate pchar }
  TcpPChar := 'tcp';
  { Do blocking call on server }
  Socket_Server_Entry := getservbyname( PortName , TcpPChar );
  { If no reply then use default from name }
  if Socket_Server_Entry = nil then
  begin
    Socket_IP_Address.sin_port := htons( StrToInt( StrPas( PortName )));
  end
  else
  begin
    { Otherwise use the replied value }
    Socket_IP_Address.sin_port := Socket_Server_Entry^.s_port;
  end;
  { Move the IP address into the data buffer }
  StrPCopy( DataBuffer , FIP_Address_Name );
  { Turn it into a real IP address in binary form }
  Socket_IP_Address.sin_addr.s_addr :=
   inet_addr( DataBuffer );
  { If not found then do remote lookup }
  if Socket_IP_Address.sin_addr.s_addr = INADDR_NONE then
  begin
    { Call blocking function on IP name }
    Socket_Host_Entry := gethostbyname( DataBuffer );
    { If still no good then error out and exit }
    if Socket_Host_Entry = nil then
    begin
      SetSocketErrorData( 'Cannot convert host address in CCSockConnect');
      exit;
    end;
    { Otherwise get the address }
    The_Socket_Host_Entry.Host_Address_List := Socket_Host_Entry^.h_addr_list;
    Socket_IP_Address.sin_addr := The_Socket_Host_Entry.Host_Address^^ ;
  end;
  { Do protocol acquisition via blocking call }
  Socket_Protocol_Entry := getprotobyname( TcpPChar );
  { Create a socket }
  FSocket := socket( PF_INET ,
                     SOCK_STREAM ,
                     Socket_Protocol_Entry^.p_proto );
  { If error code then exit with value set }
  if FSocket < 0 then
  begin
    SetSocketErrorData('CCSockConnect (socket)');
    exit;
  end;
  { If asynchmode then setup for asynch calls }
  if not FBlockingMode then
  begin
    { Do ass call and allow all callback states; note this will }
    { send a message when connected.                            }
    ReturnCode := WSAASyncSelect( FSocket , Handle , WM_ASYNCSELECT ,
      FD_READ or FD_WRITE or FD_OOB or FD_CLOSE or FD_CONNECT );
    { If get error say so }
    if ReturnCode <> 0 then SetSocketErrorData( 'WSAAsyncSelect' );
  end
  else
  begin
    { Otherwise set blocking mode }
    DummyValue := 0;
    ReturnCode := ioctlsocket( FSocket , FIONBIO , DummyValue );
    { Set up timeout on blocking call }
    ActivateNonAsynchTimeout;
    { Attempt blocking connect }
    ReturnCode := connect( FSocket ,
                           Socket_IP_Address ,
                           SizeOf( Socket_IP_Address ));
    { Deactivate timeout on blocking call }
    DeactivateNonAsynchTimeout;
    { If any other error than WouldBlock signal connection error }
    if ReturnCode <> 0 then
    begin
      ReturnCode := WSAGetLastError;
      if ReturnCode <> WSAEWOULDBLOCK then
       SetSocketErrorData( 'CCSockConnect' );
    end;
  end;
end;

{ This is a method to set the socket to a listening mode (ie server) }
procedure TCCSocket.CCSockListen;
const
  DummyValue : Longint = 0;
var
  ReturnCode : Integer;
  TcpPChar   : PChar;
  PortName   : array[0..31] of char;
  { szData: array[0..256] of char;}
begin
  { Invalid Port Name error }
  if FPort_Name = '' then
  begin
    SetSocketErrorData( 'No Port Specified in CCSockListen' );
    exit;
  end;
  { Set default AF_INET family }
  Socket_IP_Address.sin_family := AF_INET;
  { Set any IP Address }
  Socket_IP_Address.sin_addr.s_addr := INADDR_ANY;
  { Set default TCP string }
  TcpPChar := 'tcp';
  { Create PChar of port name }
  StrPCopy( PortName , FPort_Name );
  { Use blocking call to get server }
  Socket_Server_Entry := getservbyname( PortName , TcpPChar );
  { If no entry the use default number otherwise use returned one }
  if Socket_Server_Entry = nil then
     Socket_IP_Address.sin_port := htons( StrToInt( StrPas( PortName )))
  else Socket_IP_Address.sin_port := Socket_Server_Entry^.s_port;
  { Use blocking call to get protocol }
  Socket_Protocol_Entry := getprotobyname( TcpPChar );
  { Set up the server socket }
  FMasterSocket := socket( PF_INET     ,
                           SOCK_STREAM ,
                           Socket_Protocol_Entry^.p_proto );
  { If socket error return code and exit }
  if FMasterSocket < 0 then
  begin
    SetSocketErrorData( 'socket' );
    exit;
  end;
  { Bind the server socket }
  ReturnCode := bind( FMasterSocket ,
                      Socket_IP_Address,
                      SizeOf( Socket_IP_Address ));
  { If socket error then signal and exit }
  if ReturnCode <> 0 then
  begin
    SetSocketErrorData( 'Bind' );
    exit;
  end;
  { Do a listen call to set up waiting state }
  ReturnCode := listen( FMasterSocket , 5 );
  { If socket error then signal and exit }
  if ReturnCode <> 0 then
  begin
    SetSocketErrorData( 'Listen' );
    exit;
  end;
  { If not blocking do asynch call }
  if not FBlockingMode then
  begin
    { Set up asynch call }
    ReturnCode := WSAASyncSelect( FMasterSocket  ,
                                  Handle         ,
                                  WM_ASYNCSELECT ,
                                  FD_READ or FD_WRITE or FD_OOB
                                   or FD_ACCEPT or FD_CLOSE );
    { If error then signal }
    if ReturnCode <> 0 then SetSocketErrorData('WSAASyncSelect');
  end
  else ioctlsocket( FMasterSocket , FIONBIO , DummyValue ); { otherwise set blocking }
end;

{ This method terminates a listening mode (server) }
procedure TCCSocket.CCSockCancelListen;
var
  ReturnCode : Integer; { status code var }
begin
  { if not blocking then turn off asynch mode }
  if not FBlockingMode then
    WSAASyncSelect( FMasterSocket , Handle , WM_ASYNCSELECT , 0 );
  { Shutdown call }
  shutdown( FMasterSocket , 2 );
  { Close the socket }
  ReturnCode := closesocket( FMasterSocket );
  { If socket error signal it }
  if ReturnCode <> 0 then
    SetSocketErrorData( 'CancelListen (closesocket)' );
  { kill socket id }
  FMasterSocket := 0;
end;

{ This is the blocking mode accept procedure }
function TCCSocket.CCSockAccept: TSocket;
const
  DummyValue : Longint = 0;
var
  ReturnCode    : Integer; { status code }
  TheDataLength : Integer; { data length }
begin
  { Get length of the address variable }
  TheDataLength := sizeof( Socket_IP_Address );
  { if blocking then do timeout }
  if FBlockingMode then ActivateNonAsynchTimeout;
  { Do blocking accept call }
  FSocket := accept( FMasterSocket     ,
                     Socket_IP_Address ,
                     TheDataLength       );
  { If blocking }
  if FBlockingMode then
  begin
    { Kill timeout timer }
    DeactivateNonAsynchTimeout;
    { Turn on blocking on accepted socket }
    ioctlsocket( FSocket , FIONBIO , DummyValue );
  end;
  { If no accept then signal error }
  if FSocket < 0 then SetSocketErrorData( 'Accept' );
  { Return Socket ID }
  Result := FSocket;
end;

{ Close a socket in either mode }
procedure TCCSocket.CCSockClose;
var
  ReturnCode   : Integer;            { status code var }
  LingerRecord : Lingering_Control;  { linger var      }
  LingerArray  : array[ 0 .. 3 ] of char absolute LingerRecord;
                                     { pointer into la }
begin
  { If not blocking then turn of asynch messaging }
  if not FBlockingMode then
    WSAASyncSelect( FSocket , Handle , WM_ASYNCSELECT , 0 );
  { cancel any blocking }
  if WSAIsBlocking then WSACancelBlockingCall;
  { shut down the socket }
  shutdown( FSocket , 2 );
  { Set up the linger record }
  LingerRecord.l_onoff := 1;
  LingerRecord.l_linger := 0;
  { Set up the linger status via setsockopt }
  setsockopt( FSocket     ,
              SOL_SOCKET  ,
              SO_LINGER   ,
              LingerArray ,
              sizeof( LingerRecord ));
  { Do the close call }
  ReturnCode := closesocket( FSocket );
  { signal error if one happens }
  if ReturnCode <> 0 then SetSocketErrorData( 'Disconnect (closesocket)' );
  { set socket to invalid value }
  FSocket := INVALID_SOCKET;
end;

{ This sets up internal values for retrieval in case errors occur }
procedure TCCSocket.SetSocketErrorData( SocketFunction : string );
begin
  { Get any winsock error }
  ErrorCode := WSAGetLastError;
  { Get text description of error }
  WinsockErrorMessage := GetSocketErrorDescription( ErrorCode );
  { Setup full error message for user friendliness }
  if WinsockErrorMessage <> 'No Error' then
   FullErrorMessage := 'Error '+ WinsockErrorMessage +
    ' in function ' + SocketFunction else FullErrorMessage :=
     SocketFunction;
  { call error event handler }
  if Assigned( FOnErrorOccurred ) then
    FOnErrorOccurred( Self , ErrorCode , FullErrorMessage );
end;

{ Boilerplate error descriptions }
function TCCSocket.GetSocketErrorDescription( ErrorCode : Integer ) : string;
begin
  case ErrorCode of
    WSAEINTR:
      GetSocketErrorDescription := 'System Interrupt Failure';
    WSAEBADF:
      GetSocketErrorDescription := 'Bad File Failure';
    WSAEACCES:
      GetSocketErrorDescription := 'File Permission Denied Failure';
    WSAEFAULT:
      GetSocketErrorDescription := 'Bad IP Address Failure';
    WSAEINVAL:
      GetSocketErrorDescription := 'Invalid Winsock API Call Argument Failure';
    WSAEMFILE:
      GetSocketErrorDescription := 'Too Many Open Files Failure';
    WSAEWOULDBLOCK:
      GetSocketErrorDescription := 'Operation Would Block Failure';
    WSAEINPROGRESS:
      GetSocketErrorDescription := 'Operation Blocking Failure';
    WSAEALREADY:
      GetSocketErrorDescription := 'Operation Already in Progress Failure';
    WSAENOTSOCK:
      GetSocketErrorDescription := 'Invalid Socket Operation Failure';
    WSAEDESTADDRREQ:
      GetSocketErrorDescription := 'No Destination Address Failure';
    WSAEMSGSIZE:
      GetSocketErrorDescription := 'Invalid Message Length Failure';
    WSAEPROTOTYPE:
      GetSocketErrorDescription := 'Invalid Protocol For Socket Failure';
    WSAENOPROTOOPT:
      GetSocketErrorDescription := 'Unavilable Protocol Failure';
    WSAEPROTONOSUPPORT:
      GetSocketErrorDescription := 'Unsupported Protocol Failure';
    WSAESOCKTNOSUPPORT:
      GetSocketErrorDescription := 'Unsupported Socket Type Failure';
    WSAEOPNOTSUPP:
      GetSocketErrorDescription := 'Unsupported Socket Operation Failure';
    WSAEPFNOSUPPORT:
      GetSocketErrorDescription := 'Unsupported Protocol Family Failure';
    WSAEAFNOSUPPORT:
      GetSocketErrorDescription := 'Invalid Protocol-Address Family Failure';
    WSAEADDRINUSE:
      GetSocketErrorDescription := 'Address In Use Failure';
    WSAEADDRNOTAVAIL:
      GetSocketErrorDescription := 'Unavailable Address Failure';
    WSAENETDOWN:
      GetSocketErrorDescription := 'Network Down Failure';
    WSAENETUNREACH:
      GetSocketErrorDescription := 'Network Unreachable Failure';
    WSAENETRESET:
      GetSocketErrorDescription := 'Network Connection Dropped Failure';
    WSAECONNABORTED:
      GetSocketErrorDescription := 'Software Abort Failure';
    WSAECONNRESET:
      GetSocketErrorDescription := 'Peer Connection Reset Failure';
    WSAENOBUFS:
      GetSocketErrorDescription := 'Buffer Overflow Failure';
    WSAEISCONN:
      GetSocketErrorDescription := 'Connected Socket Failure';
    WSAENOTCONN:
      GetSocketErrorDescription := 'Unconnected Socket Failure';
    WSAESHUTDOWN:
      GetSocketErrorDescription := 'Closed Socket Send Failure';
    WSAETOOMANYREFS:
      GetSocketErrorDescription := 'Reference Count Overflow Failure';
    WSAETIMEDOUT:
      GetSocketErrorDescription := 'Connection Timeout Failure';
    WSAECONNREFUSED:
      GetSocketErrorDescription := 'Connection Refusal Failure';
    WSAELOOP:
      GetSocketErrorDescription := 'Symbolic Link Overflow Failure';
    WSAENAMETOOLONG:
      GetSocketErrorDescription := 'Invalid File Name Failure';
    WSAEHOSTDOWN:
      GetSocketErrorDescription := 'Host Down Failure';
    WSAEHOSTUNREACH:
      GetSocketErrorDescription := 'Host Unreachable Failure';
    WSAENOTEMPTY:
      GetSocketErrorDescription := 'Non-Empty Directory Removal Failure';
    WSAEPROCLIM:
      GetSocketErrorDescription := 'Process Overflow Failure';
    WSAEUSERS:
      GetSocketErrorDescription := 'Users Overflow Failure';
    WSAEDQUOT:
      GetSocketErrorDescription := 'Disk Quota Overflow Failure';
    WSAESTALE:
      GetSocketErrorDescription := 'Invalid File Handle Failure';
    WSAEREMOTE:
      GetSocketErrorDescription := 'File Path Overflow Failure';
    WSASYSNOTREADY:
      GetSocketErrorDescription := 'Unavailable Sub-Network Failure';
    WSAVERNOTSUPPORTED:
      GetSocketErrorDescription := 'Winsock Application Compatibility Failure';
    WSANOTINITIALISED:
      GetSocketErrorDescription := 'WinSock Uninitialized Failure';
    WSAHOST_NOT_FOUND:
      GetSocketErrorDescription := 'Host Not Located Failure';
    WSATRY_AGAIN:
      GetSocketErrorDescription := 'Non-Authority Host Not Located Failure';
    WSANO_RECOVERY:
      GetSocketErrorDescription := 'Fatal Winsock Error Failure';
    WSANO_DATA:
      GetSocketErrorDescription := 'Data Not Available Failure';
    else GetSocketErrorDescription := 'No Error';
  end;
end;

{ Activate timeout procedure }
procedure TCCSocket.ActivateNonAsynchTimeout;
begin
  if FTimeoutValue > 0 then
    SetTimer( Handle , 10 , FTimeoutValue * 1000 , nil );
end;

{ Deactivate timeout procedure }
procedure TCCSocket.DeactivateNonAsynchTimeout;
begin
  if FTimeoutValue > 0 then KillTimer( Handle , 10 );
end;
end.